home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 19 / CU Amiga Magazine's Super CD-ROM 19 (1998)(EMAP Images)(GB)[!][issue 1998-02].iso / CUCD / Utilities / Scion / ARexx / Scion2GEDCOM.rexx < prev    next >
OS/2 REXX Batch file  |  1997-11-04  |  28KB  |  924 lines
  1. /****************************************************************************
  2.  *                                                                          *
  3.  * $VER: Scion2GEDCOM 2.45 (24 Oct 1997)
  4.  *                                                                          *
  5.  *                      Written by Freddy Ariës                             *
  6.  * Address: Lindeboomweg 7, NL-7135 KE Harreveld, The Netherlands.          *
  7.  *                                                                          *
  8.  * This program was created to export the Scion data into the GEDCOM file   *
  9.  * format. It should work pretty good by now, although no guarantees        *
  10.  * whatsoever can be given. If you have any problems using this script,     *
  11.  * please describe them to me, as detailed as possible (and please also     *
  12.  * tell me what program you are using to read the GEDCOM file), then I will *
  13.  * try to work out a solution.                                              *
  14.  *                                                                          *
  15.  * GEDCOM was developed by the Family History Department of the Church of   *
  16.  * Jesus Christ of Latter-day Saints to provide a flexible uniform format   *
  17.  * for exchanging computerized genealogical data.  GEDCOM is an acronym for *
  18.  * GEnealogical Data COMmunication.  GEDCOM is provided to foster the       *
  19.  * sharing of genealogical information and the development of a wide range  *
  20.  * of inter-operable software products to assist genealogists, historians,  *
  21.  * and other researchers.                                                   *
  22.  *                                                                          *
  23.  * + SCION must be running for this AREXX script to work.                   *
  24.  * + This script uses (by default) the rexxreqtools.library (which requires *
  25.  *   a version of reqtools larger than 2.0 and rexxsyslib.library)          *
  26.  *   If you do not have these, run SetDefaults.rexx to change the settings. *
  27.  * + Dates should be in English, and in the format "DD MMM YYYY" or         *
  28.  *   "DD-MMM-YYYY", if you don't want any problems with programs importing  *
  29.  *   the GEDCOM data.                                                       *
  30.  *   If the dates in your database are not in English, please run the       *
  31.  *   Translate.rexx script first!                                           *
  32.  *                                                                          *
  33.  * DONE: - Progress indicator, using rexxarplib.library (requested by       *
  34.  *         Robbie J. Akins himself).                                        *
  35.  *       - Creation of QUAY value for date and place fields ending with '?' *
  36.  *       - Output of Scion's external note files to GEDCOM comment lines    *
  37.  *         (option)                                                         *
  38.  *       - Reference field is now output to GEDCOM's SOUR structure.        *
  39.  *       - Export of Celebrant and Witness fields, as well as Endreasons    *
  40.  *         'None' and 'Death' (temporary solution; experimental, until I    *
  41.  *         find a better way to do it). If any of these fields is           *
  42.  *         misinterpreted by your system, then please report this.          *
  43.  *       - Now uses preference file for default settings                    *
  44.  *       - Inclusion of self-defined name/address data in GEDCOM file       *
  45.  *         (optional)                                                       *
  46.  *       - CHARset set to ISO8859-1 (was: AMIGA); suggested by Robbie.      *
  47.  *       - Support for V5 date formats/preparer fields/notes attachments/   *
  48.  *         personal addresses (GEDCOM 5.3 doesn't support family addresses) *
  49.  *                                                                          *
  50.  * TO DO (but low priority, unless someone really wants this[?]):           *
  51.  *  - Add Shell options for processing of Note files                        *
  52.  *  - Add support for other character sets (now Amiga extended ASCII codes  *
  53.  *    are assumed, even though the GEDCOM format specifies the ANSEL codes  *
  54.  *    as the default)                                                       *
  55.  *  - Maybe some kind of limited export facility                            *
  56.  *  - Suggestions, comments, bugreports, donations, etc. are appreciated.   *
  57.  *                                                                          *
  58.  ****************************************************************************/
  59.  
  60. options failat 20; options results
  61. arg outname outval
  62.  
  63. versionstr = "2.45"
  64.  
  65. /* Don't change the settings here! Run SetDefaults.rexx instead! */
  66. usereq = 1; prgrs = 1; pgopen = 0
  67. outp = 1; output = stdout; scrdev = stdout
  68. notesdir = ""; pscr = ""
  69. subf = 0; subm. = ""
  70. PSCR = "SCIONGEN"
  71.  
  72. scrname = "CON:0//639//Scion_Output/AUTO/WAIT/CLOSE/SCREEN"
  73. incnote = 0;    /* include external note files */
  74. NL = '0A'x
  75.  
  76. signal on IOERR
  77.  
  78. do while outname = '?'
  79.   writeln(stdout, "OUTFILE/A,QUIET/S,NOREQ/S")
  80.   pull outname outval
  81. end
  82.  
  83. /* read preferences file */
  84.  
  85. if open(pfile, 'ENV:Scion/ScionRexx.prefs', 'r') then do
  86.   do while ~eof(pfile)
  87.     inln = readln(pfile)
  88.     if inln ~= "" then do
  89.       wstr = upper(word(inln, 1))
  90.       select
  91.     when wstr = "NOTES" then
  92.       notesdir = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
  93.     when wstr = "USEREQ" then
  94.       usereq = 1
  95.     when wstr = "NOUSEREQ" then
  96.       usereq = 0
  97.     when wstr = "PROGRESS" then
  98.       prgrs = 1
  99.     when wstr = "NOPROGRESS" then
  100.       prgrs = 0
  101.     when wstr = "PUBSCREEN" then
  102.       pscr = strip(delstr(inln, 1, length(wstr)), 'b', ' "')
  103.     when wstr = "SUB_N0" then
  104.       subm.0 = delstr(inln, 1, length(wstr)+1)
  105.     when wstr = "SUB_A1" then
  106.       subm.1 = delstr(inln, 1, length(wstr)+1)
  107.     when wstr = "SUB_A2" then
  108.       subm.2 = delstr(inln, 1, length(wstr)+1)
  109.     when wstr = "SUB_A3" then
  110.       subm.3 = delstr(inln, 1, length(wstr)+1)
  111.     when wstr = "SUB_T0" then
  112.       subm.4 = delstr(inln, 1, length(wstr)+1)
  113.     when wstr = "SUB_N1" then
  114.       subm.5 = delstr(inln, 1, length(wstr)+1)
  115.     when wstr = "SUB_N2" then
  116.       subm.6 = delstr(inln, 1, length(wstr)+1)
  117.     when wstr = "SUB_N3" then
  118.       subm.7 = delstr(inln, 1, length(wstr)+1)
  119.     when wstr = "SUB_F0" then
  120.       subf = bittst(b2c(strip(delstr(inln, 1, length(wstr)), 'b')), 0)
  121.     otherwise
  122.       /* unrecognized? skip */
  123.       end
  124.     end
  125.   end
  126.   close(pfile)
  127. end
  128.  
  129. if pscr = "" | (pscr ~= "WORKBENCH" & ~show('p', pscr)) then
  130.   pscr = "SCIONGEN"
  131. wstr = right(notesdir, 1)
  132. if wstr ~= '/' & wstr ~= ':' then notesdir = ""
  133. scrname = scrname||pscr
  134.  
  135. /* parse command line options, to enable calling the script automatically,
  136.  * eg. from a function key. This gets priority over global settings!
  137.  */
  138.  
  139. if outname ~= "" then do
  140.   if outname = "QUIET" | outname = "NOREQ" then do
  141.     outval = outname; outname = ""
  142.   end
  143. end
  144.  
  145. if outval = "QUIET" then do
  146.   outp = 0; usereq = 0; prgrs = 0
  147. end
  148. else if outval = "NOREQ" then do
  149.   usereq = 0; prgrs = 0
  150. end
  151.  
  152. if usereq & ~show('l','rexxreqtools.library') then do
  153.   if exists('libs:rexxreqtools.library') then
  154.     call addlib('rexxreqtools.library',0,-30,0)
  155.   else do
  156.     usereq = 0; outp = 1
  157.     Tell("Unable to open rexxreqtools.library - using text output")
  158.   end
  159. end
  160.  
  161. if ~usereq then prgrs = 0
  162.  
  163. if ~show('l','rexxarplib.library') then do
  164.   if exists('libs:rexxarplib.library') then do
  165.     /* rexxarplib is present - start it */
  166.     call addlib('rexxarplib.library',0,-30,0)
  167.     screentofront(pscr)
  168.   end
  169.   else
  170.     prgrs = 0
  171. end
  172. else do
  173.   /* rexxarplib is already in memory */
  174.   screentofront(pscr)
  175. end
  176.  
  177. /* Originally stolen from Peter Billing - thanks Peter ;-) */
  178. if ~show('P','SCIONGEN') then do
  179.   EndString('I am sorry to say that the SCION Genealogist' || NL ||,
  180.     'database is not available. Please start the' || NL ||,
  181.     'SCION program BEFORE using this script!')
  182. end
  183.  
  184. MyPort = "SCIONGEN"
  185. Address value MyPort
  186. GETDBNAME
  187. dbname = upper(RESULT)
  188. GETPROGVERSION
  189. prgvers = RESULT
  190.  
  191. if outp & ~usereq then do
  192.   if pscr ~= "WORKBENCH" then do
  193.     scrdev = 'SCNS2GSCR'
  194.     if ~open(scrdev, scrname, 'w') then scrdev = stdout
  195.   end
  196.   Tell("Scion to GEDCOM conversion script v"||versionstr||" by Freddy Ariës")
  197.   Tell("Database: "||dbname)
  198.   if prgvers < 5 then do
  199.     Tell("(Make sure the date fields are in English!)"|| NL)
  200.   end
  201. end
  202.  
  203. /* It may be a good habit to add the ".scion" extension */
  204. /* to Scion database files */
  205. dblen = length(dbname)
  206. if dblen>6 & right(dbname, 6)=".SCION" then dbname=left(dbname, dblen - 6)
  207.  
  208. if outname = "" then do
  209.   if outp then do
  210.     if usereq then do
  211.       odev = rtezrequest('Current Scion database: '||dbname||NL||NL||,
  212.        'Where should the GEDCOM output be sent to?'||,
  213.        '',' _File |_Printer|_Screen|_Nowhere','Scion to GEDCOM v'||versionstr||' by Freddy Ariës','rt_pubscrname = '||PSCR)
  214.       select
  215.         when odev = 1 then do
  216.           /* We need a file requester for further data */
  217.           outname = rtfilerequest(,dbname||'.GED','Output filename',,'rt_pubscrname = '||PSCR||'   rtfi_initialpath = RAM:',)
  218.           if outname = '' then
  219.             outname = dbname||'.GED'
  220.         end
  221.         when odev = 2 then
  222.           outname = 'PRT:'
  223.         when odev = 3 then
  224.           outname = 'STDOUT'
  225.         otherwise
  226.           EndString("Aborted.")
  227.           /* You selected 'Nowhere' */
  228.       end
  229.     end
  230.     else do
  231.       Tell("Enter output file (filename with complete path, or PRT: for printer,")
  232.       TellNN("or STDOUT for screen): ")
  233.       outname = readln(scrdev)
  234.       outname = strip(outname, 'b', ' "')
  235.       Tell("Destination: "||outname)
  236.       TellNN("Continue (y/n)? ")
  237.       conf = readln(scrdev)
  238.       conf = upper(left(conf, 1))
  239.       /* Note that left works on empty strings ("") too! */
  240.       if conf ~= "Y" then EndString("Aborted.")
  241.       Tell("")
  242.     end
  243.   end
  244.   else
  245.     outname = "RAM:"dbname".GED"
  246.     /* If we're not allowed to use stdout, default to this filename */
  247. end
  248.  
  249. if outp then do
  250.   if usereq then do
  251.     incnote = rtezrequest("Include Scion's external Note files "||,
  252.         NL||"in GEDCOM comment lines?"||,
  253.         '',' _Yes| _No ','Input Request:','rt_pubscrname = '||PSCR)
  254.     if incnote & notesdir = "" then do
  255.       GETDBPATH
  256.       dbpath = RESULT
  257.       notesdir = rtfilerequest(,,'Select Scion Notes Directory:','_Ok','rt_pubscrname = '||PSCR||'   rtfi_flags = freqf_nofiles   rtfi_initialpath = '||dbpath,fres)
  258.       if fres = 0 then incnote = 0
  259.         /* User cancelled requester: external note files are not used */
  260.     end
  261.   end
  262.   else do
  263.     Tell("Include Scion's external Note files in GEDCOM comment lines?")
  264.     TellNN("(y/n) : ")
  265.     ptmp = readln(scrdev)
  266.     ptmp = upper(left(ptmp, 1))
  267.     if ptmp = "Y" then incnote = 1
  268.     else incnote = 0
  269.     if incnote & notesdir = "" then do
  270.       ptmp = ""
  271.       do until ptmp = ":" | ptmp = "/"
  272.         Tell("Enter full directory name where Scion's note files are located.")
  273.         TellNN("(MUST end with ':' or '/'): ")
  274.         pname = readln(scrdev)
  275.         pname = strip(pname, 'b', ' "')
  276.         ptmp = right(pname, 1)
  277.       end
  278.       notesdir = pname
  279.     end
  280.   end
  281. end
  282.  
  283. if outname ~= "STDOUT" then do
  284.   output = 'OUTPUT'
  285.   if ~open(output, outname, "w") then
  286.     EndString("ERROR: Unable to open output file.")
  287. end
  288. else do
  289.   if ~outp | usereq then do /* output screen wasn't opened yet! */
  290.     scrdev = 'SCNS2GSCR'
  291.     if ~open(scrdev, scrname, 'w') then scrdev = stdout
  292.   end
  293.   output = scrdev
  294. end
  295.  
  296. if ~usereq then
  297.   Tell("Be patient - this may take a while...")
  298.  
  299. writeln(output, "0 HEAD")
  300. writeln(output, "1 SOUR SCION_AMIGA")
  301. writeln(output, "2 NAME Scion Genealogist")
  302. writeln(output, "2 VERS "||prgvers)
  303. writeln(output, "2 CORP Robbie J. Akins")
  304. writeln(output, "3 ADDR 5 Austin Street, Wellington 6001, New Zealand")
  305.  
  306. str = "1 DATE" upper(date())
  307. writeln(output, str)
  308. str = "1 FILE" dbname
  309. writeln(output, str)
  310. writeln(output, "1 GEDC")
  311. writeln(output, "2 VERS 5.3")
  312. writeln(output, "1 CHAR ISO8859-1"); /* 8-bit extended ASCII, Amiga format */
  313.  
  314. if (prgvers >= 5) then do
  315.   GETBRKCHAR
  316.   brkchar = RESULT
  317.   GETPREPARER
  318.   prep_addr = RESULT
  319.   if prep_addr ~= '' then
  320.   do
  321.      writeln(output, "1 SUBM @S1@")
  322.      writeln(output, "0 @S1@ SUBM")
  323.      PARSE VAR prep_addr p_name (brkchar) addr1 (brkchar) addr2 (brkchar) addr3 (brkchar)
  324.      if p_name ~= '' then
  325.      do
  326.        writeln(output, "1 NAME "||p_name)
  327.      end
  328.      if addr1 ~= '' then
  329.      do
  330.        writeln(output, "1 ADDR "||addr1)
  331.      end
  332.      if addr2 ~= '' then
  333.      do
  334.        writeln(output, "2 CONT "||addr2)
  335.      end
  336.      if addr3 ~= '' then
  337.      do
  338.        writeln(output, "2 CONT "||addr3)
  339.     end
  340.     GETPREPPHONE
  341.     prep_phone = RESULT
  342.     if prep_phone ~= '' then
  343.     do
  344.       writeln(output, "2 PHON "||prep_phone)
  345.     end
  346.   end
  347. end
  348. else if subf & (subm.0 ~= "") then do
  349.   writeln(output, "1 SUBM @S1@")
  350.   writeln(output, "0 @S1@ SUBM")
  351.   writeln(output, "1 NAME "||subm.0)
  352.   if subm.5 ~= "" then do
  353.     writeln(output, "2 NOTE "||subm.5)
  354.     if subm.6 ~= "" then writeln(output, "3 CONT "||subm.6)
  355.     if subm.7 ~= "" then writeln(output, "3 CONT "||subm.7)
  356.   end
  357.   if subm.1 ~= "" then do
  358.     writeln(output, "1 ADDR "||subm.1)
  359.     if subm.2 ~= "" then writeln(output, "2 CONT "||subm.2)
  360.     if subm.3 ~= "" then writeln(output, "2 CONT "||subm.3)
  361.     if subm.4 ~= "" then writeln(output, "2 PHON "||subm.4)
  362.   end
  363. end
  364.  
  365. if prgrs then do
  366.   Postmsg(10, 10, "Scion to GEDCOM (by Freddy Ariës)\Database: "||dbname||"\Processing person:\ ", ""||PSCR"")
  367.   pgopen = 1
  368. end
  369.  
  370. if (prgvers >= 5) then
  371. do
  372.   GETFIRSTIRN
  373.   i = RESULT
  374.   GETLASTIRN
  375.   TotalIRN = RESULT
  376.   GETBRKCHAR
  377.   brkchar = RESULT
  378. end
  379. else do
  380.   GETTOTALIRN
  381.   TotalIRN = RESULT
  382.   i = 1
  383. end
  384. do while (i > 0) & (i <= TotalIRN)
  385.   if pgopen then Postmsg(,,"\\\"||i||" (of "||TotalIRN||")", PSCR)
  386.   EXISTPERSON i
  387.   if RESULT = 'YES' then
  388.   do
  389.     str = "0 @I"i"@ INDI"
  390.     writeln(output, str)
  391.     GETFIRSTNAME i
  392.     fnames = RESULT
  393.     fnames = translate(fnames, ';', '/')
  394.     /* Fixed since v2.13: no '/' characters allowed in GEDCOM namestring! */
  395.     GETLASTNAME i
  396.     lname = RESULT
  397.     lname = translate(lname, ';', '/')
  398.     str = "1 NAME "fnames"/"lname"/"
  399.     writeln(output, str)
  400.     GETSEX i
  401.     sx = RESULT
  402.     if sx = "M" | sx = "F" then do
  403.        /* If sex is undefined ('?'), don't output anything */
  404.        str = "1 SEX" sx
  405.        writeln(output, str)
  406.     end
  407.     GETBIRTHDATE i 1
  408.     datestr = ParseDate(upper(RESULT))
  409.     GETBIRTHPLACE i
  410.     placestr = RESULT
  411.     if datestr ~= "" | placestr ~= "" then do
  412.       writeln(output, "1 BIRT")
  413.       DoOutputDate(datestr, output)
  414.       DoOutputPlace(placestr, output)
  415.     end
  416.     GETBAPTISMDATE i 1
  417.     datestr = ParseDate(upper(RESULT))
  418.     GETBAPTISMPLACE i
  419.     placestr = RESULT
  420.     if datestr ~= "" | placestr ~= "" then do
  421.       writeln(output, "1 BAPM")
  422.       DoOutputDate(datestr, output)
  423.       DoOutputPlace(placestr, output)
  424.     end
  425.     GETDEATHDATE i 1
  426.     datestr = ParseDate(RESULT)
  427.     GETDEATHPLACE i
  428.     placestr = RESULT
  429.     GETDIEDOF i
  430.     diedofstr = RESULT
  431.     if datestr ~= "" | placestr ~= "" | diedofstr ~= "" then do
  432.       writeln(output, "1 DEAT")
  433.       DoOutputDate(datestr, output)
  434.       DoOutputPlace(placestr, output)
  435.       if diedofstr ~= "" then do
  436.     str = "2 CAUS" diedofstr
  437.     writeln(output, str)
  438.       end
  439.     end
  440.     GETBURIALDATE i 1
  441.     datestr = ParseDate(RESULT)
  442.     GETBURIALPLACE i
  443.     placestr = RESULT
  444.     if datestr ~= "" | placestr ~= "" then do
  445.       writeln(output, "1 BURI")
  446.       DoOutputDate(datestr, output)
  447.       DoOutputPlace(placestr, output)
  448.     end
  449.     if prgvers >= 5 then do
  450.       GETPERSADDR i
  451.       pers_addr = RESULT
  452.       PARSE VAR pers_addr line_1 (brkchar) line_2 (brkchar) line_3 (brkchar) line_4 (brkchar)
  453.       GETPERSPHONE i
  454.       pers_phone = RESULT
  455.       if line_1 ~= '' then do
  456.         writeln(output, "1 ADDR "||line_1)
  457.         if line_2 ~= '' then do
  458.           writeln(output, "2 CONT "||line_2)
  459.         end
  460.         if line_3 ~= '' then do
  461.           writeln(output, "2 CONT "||line_3)
  462.         end
  463.         if line_4 ~= '' then do
  464.           writeln(output, "2 CONT "||line_4)
  465.         end
  466.         if pers_phone ~= '' then do
  467.           writeln(output, "2 PHON "||pers_phone)
  468.         end
  469.       end
  470.     end
  471.     GETRELIGION i
  472.     rs1 = RESULT
  473.     if rs1 ~= "" then do
  474.       str = "1 RELI" rs1
  475.       writeln(output, str)
  476.     end
  477.     GETEDUCATION i
  478.     rs1 = RESULT
  479.     if rs1 ~= "" then do
  480.       str = "1 EDUC" rs1
  481.       writeln(output, str)
  482.     end
  483.     GETOCCUPATION i
  484.     rs1 = RESULT
  485.     if rs1 ~= "" then do
  486.       str = "1 OCCU" rs1
  487.       writeln(output, str)
  488.     end
  489.     comset = 0
  490.     GETPERSCOMMENT i
  491.     rs1 = RESULT
  492.     if rs1 ~= "" & rs1 ~= "[see notes]" then do
  493.       str = "1 NOTE" rs1
  494.       writeln(output, str)
  495.       comset = 1
  496.     end
  497.     if incnote then do
  498.       iname = notesdir||"PN"||i||"."||dbname
  499.       if prgvers >= 5 then do
  500.         GETPERSNOTE i
  501.         notespath = RESULT
  502.         if notespath ~= '' then
  503.           iname = notespath
  504.       end
  505.       ParseCommentFile(iname, comset)
  506.     end
  507.     GETPERSREFS i
  508.     rs2 = RESULT
  509.     if rs2 ~= "" then do
  510.       str = "1 SOUR" rs2
  511.       writeln(output, str)
  512.     end
  513.     GETPARENTS i
  514.     ParFGRN = RESULT
  515.     EXISTFAMILY ParFGRN
  516.     if RESULT = 'YES' then do
  517.       str = "1 FAMC @F"ParFGRN"@"
  518.       writeln(output, str)
  519.     end
  520.     HuwNum = 0
  521.     GETMARRIAGE i HuwNum
  522.     MarrFGRN = RESULT
  523.     do while MarrFGRN ~= ""
  524.       EXISTFAMILY MarrFGRN
  525.       if RESULT = 'YES' then do
  526.         str = "1 FAMS @F"MarrFGRN"@"
  527.         writeln(output, str)
  528.       end
  529.       HuwNum = HuwNum + 1
  530.       GETMARRIAGE i HuwNum
  531.       MarrFGRN = RESULT
  532.     end
  533.   end
  534.   if (prgvers >= 5) then
  535.   do
  536.      GETNEXTIRN i
  537.      i = RESULT
  538.   end
  539.   else do
  540.      i = i + 1
  541.   end
  542. end
  543. if ~usereq & output ~= scrdev then
  544. do
  545.   Tell("Number of persons output: "||TotalIRN)
  546.   /* output to screen only if it doesn't end up
  547.    * in the middle of the GEDCOM file!
  548.    */
  549. end
  550.  
  551. /* Now the list of families... */
  552.  
  553. if pgopen then Postmsg(,, "\\Processing family:\ ", PSCR)
  554.  
  555. if (prgvers >= 5) then
  556. do
  557.   GETFIRSTFGRN
  558.   i = RESULT
  559.   GETLASTFGRN
  560.   TotalFGRN = RESULT
  561. end
  562. else do
  563.   GETTOTALFGRN
  564.   TotalFGRN = RESULT
  565.   i = 1
  566. end
  567.  
  568. do while (i > 0) & (i <= TotalFGRN)
  569.   if pgopen then Postmsg(,, "\\\"||i||" (of "||TotalFGRN||")", PSCR)
  570.   EXISTFAMILY i
  571.   if RESULT = 'YES' then do
  572.     str = "0 @F"i"@ FAM"
  573.     writeln(output, str)
  574.     GETPRINCIPAL i
  575.     husb = RESULT
  576.     if husb ~= "" then do
  577.        EXISTPERSON husb
  578.        if RESULT = 'YES' then do
  579.       GETSEX husb
  580.       hsx = RESULT
  581.       /* Note: GEDCOM requires 1 husband (male) and 1 wife (female).
  582.        * Scion allows more unconventional partnerships as well, so we have
  583.        * to improvise a bit here...
  584.        */
  585.       GETSPOUSE i
  586.       wife = RESULT
  587.       if wife ~= "" then do
  588.          EXISTPERSON wife
  589.          if RESULT = 'YES' then do
  590.                 if hsx = "M" then wsx = "F"
  591.                 else if hsx = "F" then wsx = "M"
  592.                 else do
  593.                    /* principal's sex is undefined. Try to determine it
  594.                     * using the sex of the spouse. If both are undefined,
  595.                     * assume principal is male and spouse is female.
  596.                     */
  597.                GETSEX wife
  598.                wsx = RESULT
  599.                    if wsx = "M" then hsx = "F"
  600.                    else hsx = "M"
  601.                 end
  602.                 if wsx = "M" then do
  603.                str = "1 HUSB @I"wife"@"
  604.                writeln(output, str)
  605.                 end
  606.                 else do
  607.                str = "1 WIFE @I"wife"@"
  608.                    writeln(output, str)
  609.                 end
  610.              end
  611.           end
  612.       if hsx ~= "F" then do
  613.          str = "1 HUSB @I"husb"@"
  614.            writeln(output, str)
  615.           end
  616.           else do
  617.          str = "1 WIFE @I"husb"@"
  618.          writeln(output, str)
  619.           end
  620.        end
  621.     end
  622.     GETENGAGEDATE i 1
  623.     datestr = ParseDate(RESULT)
  624.     GETENGAGEPLACE i
  625.     placestr = RESULT
  626.     if datestr ~= "" | placestr ~= "" then do
  627.       writeln(output, "1 ENGA")
  628.       DoOutputDate(datestr, output)
  629.       DoOutputPlace(placestr, output)
  630.     end
  631.     datestr = ""; placestr = ""
  632.     GETMARRYDATE i 1
  633.     datestr = ParseDate(RESULT)
  634.     GETMARRYPLACE i
  635.     placestr = RESULT
  636.     GETCELEBRANT i
  637.     clbrnt = RESULT
  638.     GETWITNESS i
  639.     wtness = RESULT
  640.     if datestr ~= "" | placestr ~= "" | clbrnt ~= "" | wtness ~= "" then do
  641.       writeln(output, "1 MARR")
  642.       DoOutputDate(datestr, output)
  643.       DoOutputPlace(placestr, output)
  644.       if clbrnt ~= "" then do
  645.     str = "2 OFFI" clbrnt
  646.     writeln(output, str)
  647.       end
  648.       if wtness ~= "" then do
  649.     str = "2 WITN" wtness
  650.     writeln(output, str)
  651.       end
  652.       /* Note that OFFI and WITN in this context are not official GEDCOM 5.3,
  653.        * but at least this way, they won't get lost when we export Scion data
  654.        * and then import the exported file again.
  655.        */
  656.     end
  657.     GETENDING i
  658.     endstr = RESULT
  659.     if endstr >= 1 & endstr <= 5 then do
  660.       /* DIV N is used eg. by PAF 2.2. It's not official GEDCOM 5.3, but I
  661.        * hope other programs can recognize it and are not confused by it.
  662.        */
  663.       if endstr = 1 then
  664.         writeln(output, "1 DIV N")
  665.       else if endstr = 2 then do
  666.         writeln(output, "1 DIV")
  667.         writeln(output, "2 TYPE DIVORCE")
  668.       end
  669.       else if endstr = 3 then do
  670.         writeln(output, "1 DIV")
  671.         writeln(output, "2 TYPE SEPARATED")
  672.       end
  673.       else if endstr = 4 then
  674.         writeln(output, "1 ANUL")
  675.       else if endstr = 5 then do
  676.         writeln(output, "1 DIV N")
  677.         writeln(output, "2 TYPE DEATH")
  678.     /* I hope this doesn't confuse other programs too much !?! */
  679.     /* This is just a temporary solution, until I find a better way */
  680.       end
  681.       datestr = ""; placestr = ""
  682.       GETENDDATE i 1
  683.       datestr = ParseDate(RESULT)
  684.       DoOutputDate(datestr, output)
  685.       GETENDPLACE i
  686.       placestr = RESULT
  687.       DoOutputPlace(placestr, output)
  688.     end
  689.     comset = 0
  690.     GETFAMCOMMENT i
  691.     rs1 = RESULT
  692.     if rs1 ~= "" & rs1 ~= "[see notes]" then do
  693.       str = "1 NOTE" rs1
  694.       writeln(output, str)
  695.       comset = 1
  696.     end
  697.     if incnote then do
  698.       fname = notesdir||"FN"||i||"."||dbname
  699.       if prgvers >= 5 then do
  700.         GETFAMNOTE i
  701.         notespath = RESULT
  702.         if notespath ~= '' then
  703.           fname = notespath
  704.       end
  705.       ParseCommentFile(fname, comset)
  706.     end
  707.  
  708.     GETFAMREFS i
  709.     rs2 = RESULT
  710.     if rs2 ~= "" then do
  711.       str = "1 SOUR" rs2
  712.       writeln(output, str)
  713.     end
  714.  
  715.     ChNum = 0
  716.     GETCHILD i ChNum
  717.     ChIRN = RESULT
  718.     do while ChIRN ~= ""
  719.       EXISTPERSON ChIRN
  720.       if RESULT = 'YES' then do
  721.         str = "1 CHIL @I"ChIRN"@"
  722.         writeln(output, str)
  723.       end
  724.       ChNum = ChNum + 1
  725.       GETCHILD i ChNum
  726.       ChIRN = RESULT
  727.     end
  728.     /* optional:
  729.        str = "1 NCHI" ChNum
  730.        writeln(output, str)
  731.      */
  732.   end
  733.   if (prgvers >= 5) then
  734.   do
  735.      GETNEXTFGRN i
  736.      i = RESULT
  737.   end
  738.   else do
  739.      i = i + 1
  740.   end
  741. end
  742. writeln(output, "0 TRLR")
  743.  
  744. if usereq then
  745.   EndString('Conversion done.'||NL||'Number of persons output: '||TotalIRN||,
  746.     NL||'Number of families output: '||TotalFGRN||NL)
  747. else do
  748.   if output = scrdev then
  749.     Tell("Number of persons output: "||TotalIRN)
  750.   EndString("Number of families output: "||TotalFGRN)
  751. end
  752.  
  753. EXIT
  754.  
  755. /*
  756.  * Read external comment files and output to the GEDCOM file
  757.  */
  758. ParseCommentFile: PROCEDURE EXPOSE output
  759. parse arg iname,coms
  760. if ~open(infile, iname, "r") then
  761.   return 0
  762. do while ~eof(infile)
  763.   cline = GetNextCLine(infile)
  764.   if cline ~= "" | ~eof(infile) then do
  765.     if coms then
  766.       str = "2 CONT "||cline
  767.     else do
  768.       str = "1 NOTE "||cline
  769.       coms = 1
  770.     end
  771.     writeln(output, str)
  772.   end  
  773. end
  774. close(infile)
  775. return 0
  776.  
  777. /* read a line from a file; skip empty lines */
  778. GetNextCLine: PROCEDURE
  779. parse arg infile
  780. ignl = ""
  781. if ~eof(infile) then
  782.   ignl = readln(infile)
  783.   /* ignl = strip(ignl, 'b', ' '); * should we remove extra spaces? No! */
  784. return ignl
  785.  
  786. ParseDate: PROCEDURE EXPOSE prgvers
  787. parse arg datestr
  788. /* replace all ".", "-" or "/" in the date by " " */
  789. if datestr = '' then return datestr
  790. datestr = upper(translate(datestr,'   ','-./'))
  791. if prgvers < 5 then do
  792.    /* replace ABOUT by ABT, BEFORE by BEF and AFTER by AFT */
  793.    if left(datestr, 5) = "ABOUT" then
  794.      datestr = "ABT"||right(datestr,length(datestr)-5)
  795.    else if left(datestr, 6) = "BEFORE" then
  796.      datestr = "BEF"||right(datestr,length(datestr)-6)
  797.    else if left(datestr, 5) = "AFTER" then
  798.      datestr = "AFT"||right(datestr,length(datestr)-5)
  799.    return datestr
  800. end
  801. else do
  802.    datesArray = "JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC"
  803.  
  804.    /* As of v5, dates can be numeric, including 00-00-0000
  805.     * in front of date: < (=BEF), > (=AFT), ~ (=ABT),
  806.     * behind date: ? (uncertain), BC (=B.C.) [in that order!]
  807.     * Note: pre-v5 versions of Scion ignore the additional 1
  808.     * behind the GETxxxDATE commands
  809.     */
  810.    retstr=""; leadstr=""; quay=""
  811.    if left(datestr, 1) = '~' then do
  812.      leadstr = 'ABT '
  813.      datestr = right(datestr, length(datestr)-1)
  814.    end
  815.    else if left(datestr, 1) = '<' then do
  816.      leadstr = 'BEF '
  817.      datestr = right(datestr, length(datestr)-1)
  818.    end
  819.    else if left(datestr, 1) = '>' then do
  820.      leadstr = 'AFT '
  821.      datestr = right(datestr, length(datestr)-1)
  822.    end
  823.    if right(datestr, 2) = 'BC' then do
  824.      retstr = ' B.C.'
  825.      datestr = strip(left(datestr, length(datestr)-2), 'T')
  826.    end
  827.    if right(datestr, 1) = '?' then do
  828.      quay = '?'
  829.      /* required furtheron! */
  830.      datestr = left(datestr, length(datestr)-1)
  831.    end
  832.    w1 = words(datestr)
  833.    if w1 > 0 then do
  834.      d1str = word(datestr, w1)
  835.      /* note that '0' IS a valid year! */
  836.      year = strip(d1str, 'L', '0')
  837.      if year = '' then
  838.         year = '0'
  839.      retstr = year||retstr
  840.      datestr = strip(left(datestr, length(datestr)-length(d1str)), 'T')
  841.    end
  842.    w1 = w1 - 1
  843.    if w1 > 0 then do
  844.      d1str = word(datestr, words(datestr))
  845.      if d1str ~= "00" then do
  846.         /* month specified */
  847.         monthname = word(datesArray, d1str)
  848.         retstr = monthname||' '||retstr
  849.      end
  850.      datestr = strip(left(datestr, length(datestr)-length(d1str)), 'T')
  851.    end
  852.    w1 = w1 - 1
  853.    if w1 > 0 then do
  854.      d1str = word(datestr, words(datestr))
  855.      if d1str ~= "00" then do
  856.         /* day specified */
  857.         retstr = strip(d1str,'L','0')||' '||retstr
  858.      end
  859.      datestr = left(datestr, length(datestr)-length(d1str))
  860.    end
  861.    return leadstr||retstr||quay
  862. end
  863.  
  864. DoOutputDate: PROCEDURE
  865. parse arg datestr, output
  866. if datestr ~= "" then do
  867.   qy = right(datestr,1)
  868.   if qy="?" then
  869.     datestr = left(datestr, length(datestr)-1)
  870.   str = "2 DATE" datestr
  871.   writeln(output, str)
  872.   if qy="?" then
  873.     writeln(output, "3 QUAY 0")
  874. end
  875. return 0
  876.  
  877. DoOutputPlace: PROCEDURE
  878. parse arg placestr, output
  879. if placestr ~= "" then do
  880.   qy = right(placestr,1)
  881.   if qy="?" then
  882.     placestr = left(placestr, length(placestr)-1)
  883.   str = "2 PLAC" placestr
  884.   writeln(output, str)
  885.   if qy="?" then
  886.     writeln(output, "3 QUAY 0")
  887. end
  888. return 0
  889.  
  890. Tell: PROCEDURE EXPOSE outp scrdev
  891. parse arg str
  892. if outp then writeln(scrdev, str)
  893. return 0
  894.  
  895. TellNN: PROCEDURE EXPOSE outp scrdev
  896. parse arg str
  897. if outp then writech(scrdev, str)
  898. return 0
  899.  
  900. EndString: PROCEDURE EXPOSE outp output usereq scrdev pgopen pscr
  901. parse arg str
  902. if pgopen then Postmsg()
  903. /* If you turned off stdout, no error messages will be shown! */
  904. if usereq then
  905.   rtezrequest(str,'E_xit','Converter Message:','rt_pubscrname = '||pscr)
  906. else
  907.   Tell(str || '0A'x)
  908. if outp & ~usereq & (scrdev ~= stdout) then do
  909.   Tell("Press <return> to exit.")
  910.   readln(scrdev)
  911.   close(scrdev)
  912. end
  913. close(output)
  914. EXIT
  915.  
  916. /* Let's make sure you get a nice message when you turn off the printer :-) */
  917.  
  918. IOERR:
  919.   bline = SIGL
  920.   say "I/O error #"||RC||" detected in line "||bline||":"
  921.   say sourceline(bline)
  922.   if pgopen then Postmsg()
  923.   EXIT
  924.